home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / old-static.scm < prev    next >
Text File  |  1995-10-13  |  9KB  |  304 lines
  1. ;;; Static heaps for the Scheme Shell
  2. ;;; Copyright (c) 1994 by Brian D. Carlstrom.
  3.  
  4. ;;; based on Scheme48 implementation.
  5. ;;; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
  6.  
  7. ;;; TODO
  8. ;;; get it working
  9.  
  10. #!
  11. ,config ,load vm/ps-interface.scm
  12. ,config ,load vm/interfaces.scm
  13. ,config ,load vm/package-defs.scm
  14. ;; Undefined: (pre-scheme vm-utilities system-spec external)
  15. ,config ,load vm/s48-package-defs.scm
  16.  
  17. ,load-package bigbit
  18. ,load-package destructuring
  19.  
  20. ,load-package heap
  21. ,in heap 
  22. (define (newspace-begin) *newspace-begin*)
  23. (define (heap-pointer) *hp*)
  24. ,structure heap-extra (export newspace-begin
  25.                   heap-pointer
  26.                   header-a-units
  27.                   d-vector? 
  28.                   stob-type)
  29.  
  30. ,config 
  31. (define-structure static (export do-it
  32.                  make-static-heap
  33.                  test)
  34.   (open scheme heap memory data stob struct
  35.     heap-extra
  36.     vm-architecture
  37.     formats
  38.     enumerated
  39.     signals
  40.     scsh)
  41.   (files (scsh static)))
  42.  
  43. ,user
  44. ,load-package static
  45. ,open static
  46. (test)
  47. !#
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49.  
  50. (define *scsh-image* "scsh/scsh.image")    ; input file
  51. (define *scsh-image* "debug/tiny.image") ; input file
  52. (define *image-lib*  "scsh.a")        ; output file
  53. (define *temp-dir*   (string-append
  54.               "/tmp/"
  55.               "scsh"
  56.               (number->string
  57.                (pid)))) ;; prefix for temp files - in their own dir
  58. (define *prefix*     (string-append *temp-dir* "/"))
  59.  
  60. (define (make-static-heap image archive)
  61.   (if (file-exists? *temp-dir*)
  62.       (if (equal? 'directory (file-info:type (file-attributes *temp-dir*)))
  63.       (with-cwd *temp-dir* 
  64.             (map delete-file (directory-files *temp-dir* #t)))
  65.       (delete-file *temp-dir*)))
  66.   (create-directory *temp-dir* #o755 #t)
  67.   (let ((size (file-info:size (file-attributes image))))
  68.     (do-it size image *prefix*)))
  69.  
  70. (define (test) 
  71.   (make-static-heap *scsh-image* *image-lib*))
  72. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73.  
  74.  
  75.  
  76. ; For example:
  77. ;   (do-it 100000 "~/s48/debug/little.image" "little-heap.c")
  78. ;
  79. ; The first argument to do-it should be somewhat larger than the size,
  80. ; in bytes, of the image file to be converted (which you can obtain with
  81. ; "ls -l").
  82. ;
  83. ; If the image contains 0-length stored objects, then the .c file will
  84. ; have to be compiled by gcc, since 0-length arrays aren't allowed in
  85. ; ANSI C.  This wouldn't be difficult to work around.
  86.  
  87. (define *comments?* #f)
  88.  
  89. ; 800,000 bytes => 200,000 words => at least 100,000 objects
  90. ;   50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk
  91. (define *chunk-size* 10000)
  92.  
  93. (define (do-it bytes infile prefix)
  94.   (let ((start (init bytes infile)))
  95.     (emit-area-declarations "p" immutable? "const " prefix)
  96.     (emit-area-declarations "i" mutable? "" prefix)
  97.     (emit-area-initializers "p" immutable? "const " prefix)
  98.     (emit-area-initializers "i" mutable? "" prefix)
  99.     (call-with-output-file (string-append prefix "entry.c")
  100.       (lambda (port)
  101.     (display "#include \"" port)
  102.     (display prefix port)
  103.     (display (descriptor-include start) port)
  104.     (display ".h\"" port)
  105.     (newline port)
  106.     (display "const long entry = " port)
  107.     (emit-descriptor start port)
  108.     (write-char #\; port)
  109.     (newline port)))))
  110.  
  111. (define (init bytes infile)
  112.   (create-memory (quotient bytes 2) quiescent) ;Output of ls -l
  113.   (initialize-heap (memory-begin) (memory-size))
  114.   (let ((start (read-image infile 0)))
  115.     (let ((n (nchunks)))
  116.       (message n (if (= n 1) " chunk" " chunks")))
  117.     start))
  118.  
  119. (define (nchunks) (+ (chunk-number (heap-pointer)) 1))
  120.  
  121. ; emit struct declarations for areas
  122.  
  123. (define (emit-area-declarations name in-area? const prefix)
  124.   (for-each-stored-object 
  125.    (string-append prefix name) ".h"
  126.    (lambda (chunk port)
  127.      (message name chunk " declaration")
  128.      (format port "#define D(x) (long)(&x)+7~%")
  129.      (format port "#define H unsigned long~%")
  130.      (display "struct " port) (display name port) (display chunk port)
  131.      (display " {" port) (newline port))
  132.    (lambda (x port)
  133.      (if (in-area? x)
  134.      (emit-declaration x port)))
  135.    (lambda (chunk port)
  136.      (display "};" port)
  137.      (newline port)
  138.      (display const port)
  139.      (display "extern struct " port) 
  140.      (display name port) 
  141.      (display chunk port)
  142.      (write-char #\space port) (display name port) (display chunk port)
  143.      (write-char #\; port) (newline port)
  144.      chunk)))
  145.  
  146. (define (emit-declaration x port)
  147.   (display "  H x" port)
  148.   (writex x port)
  149.   (cond ((d-vector? x)
  150.      (display "; long d" port)
  151.      (writex x port)
  152.      (write-char #\[ port)
  153.      (write (d-vector-length x) port))
  154.     ((vm-string? x)
  155.      (display "; char d" port)
  156.      (writex x port)
  157.      (write-char #\[ port)
  158.      ;; Ensure alignment (thanks Ian)
  159.      (write (cells->bytes (bytes->cells (b-vector-length x)))
  160.         port))
  161.     (else
  162.      (display "; unsigned char d" port)
  163.      (writex x port)
  164.      (write-char #\[ port)
  165.      ;; Ensure alignment
  166.      (write (cells->bytes (bytes->cells (b-vector-length x)))
  167.         port)))
  168.   (display "];" port)
  169.   (if *comments?*
  170.       (begin (display " /* " port)
  171.          (display (enumerand->name (stob-type x) stob) port)
  172.          (display " */" port)))
  173.   (newline port))
  174.  
  175. ; Emit initializers for areas
  176.  
  177. (define (emit-area-initializers name in-area? const prefix)
  178.   (for-each-stored-object
  179.    (string-append prefix name) ".c"
  180.    (lambda (chunk port)
  181.      (message name chunk " initializer")
  182.      (display const port)
  183.      (display "struct " port) (display name port) (write chunk port)
  184.      (write-char #\space port) (display name port) (write chunk port)
  185.      (display " =" port) (newline port)
  186.  
  187.      (write-char #\{ port) (newline port))
  188.    (lambda (x port)
  189.      (if (in-area? x)
  190.      (emit-initializer x port)))
  191.    (lambda (chunk port)
  192.      (display "};" port) (newline port)))
  193.  
  194.   (call-with-output-file 
  195.       (string-append prefix ".c")
  196.     (lambda (port)
  197.       (let ((n (nchunks)))
  198.     (format port "const long ~a_count = ~s;~%" name n)
  199.     (format port "~a long * const ~a_areas[~s] = {" const name n)
  200.     (do ((i 0 (+ i 1)))
  201.         ((= i n))
  202.       (format port "(~a long *)&~a~s, " const name i))
  203.     (format port "};~%const long ~a_sizes[~s] = {" name n)
  204.     (do ((i 0 (+ i 1)))
  205.         ((= i n))
  206.       (format port "sizeof(~a~s), " name i))
  207.     (format port "};~%")))))
  208.  
  209.  
  210. (define (message . stuff)
  211.   (for-each display stuff) (newline))
  212.  
  213. (define (emit-initializer x port)
  214.   (display "  " port)
  215.   (write (stob-header x) port)
  216.   (write-char #\, port)
  217.   (cond ((d-vector? x)
  218.      (emit-d-vector-initializer x port))
  219.     ((vm-string? x)
  220.      (write-char #\" port)
  221.      (let ((len (vm-string-length x)))
  222.        (do ((i 0 (+ i 1)))
  223.            ((= i len) (write-char #\" port))
  224.          (let ((c (vm-string-ref x i)))
  225.            (cond ((or (char=? c #\") (char=? c #\\))
  226.               (write-char #\\ port))
  227.              ((char=? c #\newline)
  228.               (display "\\n\\" port)))
  229.            (write-char c port)))))
  230.     (else
  231.      (write-char #\{ port)
  232.      (let ((len (b-vector-length x)))
  233.        (do ((i 0 (+ i 1)))
  234.            ((= i len) (write-char #\} port))
  235.          (write (b-vector-ref x i) port)
  236.          (write-char #\, port)))))
  237.   (write-char #\, port)
  238.   (if *comments?*
  239.       (begin (display " /* " port)
  240.          (writex x port)
  241.          (display " */" port)))
  242.   (newline port))
  243.  
  244. (define (emit-d-vector-initializer x port)
  245.   (write-char #\{ port)
  246.   (let ((len (d-vector-length x)))
  247.     (do ((i 0 (+ i 1)))
  248.     ((= i len) (write-char #\} port))
  249.       (emit-descriptor (d-vector-ref x i) port)
  250.       (write-char #\, port))))
  251.  
  252. (define (emit-descriptor x port)
  253.   (if (stob? x)
  254.       (begin (if (immutable? x)
  255.          (display "D(p" port)
  256.          (display "D(i" port))
  257.          (display (chunk-number x) port)
  258.          (display ".x" port)
  259.          (writex x port)
  260.          (write-char #\) port))
  261.       (write x port)))
  262.  
  263. ; hacked emit-descriptor returns chunk or #f
  264. (define (descriptor-include x)
  265.   (if (stob? x)
  266.       (string-append 
  267.        (if (immutable? x) "p" "i")
  268.        (number->string (chunk-number x)))
  269.       #f))
  270.  
  271. ; Foo
  272.  
  273. (define (writex x port)
  274.   (write (quotient (- (- x (memory-begin)) 7) 4) port))
  275.  
  276. (define (chunk-number x)
  277.   (quotient (- (- x (memory-begin)) 7) *chunk-size*))
  278.  
  279.  
  280. ; Image traversal utility
  281.  
  282. (define (for-each-stored-object suffix chunk-start proc chunk-end)
  283.   (let ((limit (heap-pointer)))
  284.     (let chunk-loop ((addr (newspace-begin))
  285.              (i 0)
  286.              (chunk (+ (newspace-begin) *chunk-size*)))
  287.       (if (addr< addr limit)
  288.       (begin
  289.         (chunk-start i)
  290.         (let loop ((addr addr))
  291.           (if (and (addr< addr limit)
  292.                (addr< addr chunk))
  293.           (let ((d (fetch addr)))
  294.             (if (not (header? d))
  295.             (warn "heap is in an inconsistent state" d))
  296.             (proc (address->stob-descriptor (addr1+ addr)))
  297.             (loop (addr1+ (addr+ addr (header-a-units d)))))
  298.           (begin (chunk-end i)
  299.              (chunk-loop addr
  300.                      (+ i 1)
  301.                      (+ chunk *chunk-size*))))))))))
  302.  
  303. (define (mutable? x) (not (immutable? x)))
  304.